import Data.List
import Data.Maybe
import Monad
import Data.Ord
import qualified Data.Set as Set
import Data.Function

data Note = C | C' | D | D' | E | F | F' | G | G' | A | A' | B
    deriving (Enum, Bounded, Eq, Ord)

data ScaleDegree = I | II | III | IV | V | VI | VII
    deriving (Enum, Bounded, Eq, Ord)

data Quality = Major | Minor | Perfect | Augmented | Diminished deriving Eq
type DiatonicNumber = Int

data ChordType =
      Triad Quality Quality
    | SeventhChord ChordType Quality
    -- | ExtendedChord ...
    -- | AlteredChord ...
    -- | AddedChord ...
    | SuspendedChord DiatonicNumber ChordType
    deriving Eq

-- Triad Chords
major = Triad Major Perfect
minor = Triad Minor Perfect
augmented = Triad Major Augmented
diminished = Triad Minor Diminished

-- Seventh Chords
diminished7th = SeventhChord diminished Diminished
halfDiminished7th = SeventhChord diminished Minor
minor7th = SeventhChord minor Minor
minorMajor7th = SeventhChord minor Major
dominant7th = SeventhChord major Minor
major7th = SeventhChord major Major
augmented7th = SeventhChord augmented Minor
augmentedMajor7th = SeventhChord augmented Major

-- Suspended Chords
sus2 = SuspendedChord 2
sus4 = SuspendedChord 4

allChordTypes = map fst chordTypeNames

data ScaleType =
      MajorPentatonic
    | MinorPentatonic
    | MajorDiatonic
    | MinorDiatonic
    deriving (Eq, Bounded, Enum, Show)

data Chord = Chord Note ChordType deriving (Eq)
data Scale = Scale Note ScaleType deriving (Show)

data DiatonicInterval =
      PerfectUnison
    | MinorSecond
    | MajorSecond
    | MinorThird
    | MajorThird
    | PerfectFourth
    | AugmentedFourth
    | PerfectFifth
    | MinorSixth
    | MajorSixth
    | MinorSeventh
    | MajorSeventh
    | PerfectOctave
    deriving (Eq, Bounded, Enum, Show)

class NoteSet a where
    notes :: a -> [Note]

instance NoteSet Chord where
    notes (Chord root chordType) = root : map (add root) (cIntervals chordType)

instance NoteSet Scale where
    notes (Scale root scaleType) = map (add root) (sIntervals scaleType)

cNotes :: Chord -> [Note]
cNotes = notes

sNotes :: Scale -> [Note]
sNotes = notes

cIntervals :: ChordType -> [DiatonicInterval]
cIntervals (Triad q3 q5) = [interval 3 q3, interval 5 q5]
cIntervals (SeventhChord triad q7) = (cIntervals triad) ++ [interval 7 q7]
cIntervals (SuspendedChord factor chord) =
    (cIntervals chord \\ [MajorThird, MinorThird])
    ++ [if factor == 2 then MajorSecond else PerfectFourth]

-- helper, temporay hack
interval :: DiatonicNumber -> Quality -> DiatonicInterval
interval 3 Major = MajorThird
interval 3 Minor = MinorThird
interval 5 Diminished = diminish PerfectFifth
interval 5 Perfect = PerfectFifth
interval 5 Augmented = augment PerfectFifth
interval 7 Diminished = diminish MinorSeventh
interval 7 Major = MajorSeventh
interval 7 Minor = MinorSeventh

sIntervals :: ScaleType -> [DiatonicInterval]
sIntervals MajorPentatonic =
	[PerfectUnison, MajorSecond, MajorThird, PerfectFifth, MajorSixth]
sIntervals MinorPentatonic =
	[PerfectUnison, MinorThird, PerfectFourth, PerfectFifth, MinorSeventh]
sIntervals MajorDiatonic =
	[PerfectUnison, MajorSecond, MajorThird, PerfectFourth, PerfectFifth,
         MajorSixth, MajorSeventh]
sIntervals MinorDiatonic =
	[PerfectUnison, MajorSecond, MinorThird, PerfectFourth, PerfectFifth,
         MinorSixth, MinorSeventh]

circleOfFifths :: Note -> [Note]
circleOfFifths note = iterate (flip add PerfectFifth) note

add :: (Eq a, Bounded a, Enum a, Enum b) => a -> b -> a
add x n = toEnum $ (fromEnum x + fromEnum n) `mod`
                   (fromEnum (maxBound `asTypeOf` x)+1)

diminish :: DiatonicInterval -> DiatonicInterval
diminish interval = interval `add` (-1)

doublyDiminish :: DiatonicInterval -> DiatonicInterval
doublyDiminish = diminish . diminish

augment :: DiatonicInterval -> DiatonicInterval
augment interval = interval `add` 1

doublyAugment :: DiatonicInterval -> DiatonicInterval
doublyAugment = augment . augment

triadsInScale :: Scale -> [Chord]
triadsInScale scale = filter isTriad (chordsInScale scale)
    where isTriad :: Chord -> Bool
          isTriad (Chord _ (Triad _ _)) = True
          isTriad _ = False

chordsOfTypeInScale :: Scale -> ChordType -> [Chord]
chordsOfTypeInScale scale chordType =
    filter (\(Chord _ cType) -> cType == chordType) (chordsInScale scale)

chordsInScale :: Scale -> [Chord]
chordsInScale scale =
    [ chord |
      n <- [minBound..],
      t <- allChordTypes,
      let chord = Chord n t,
      inScale scale chord]

scalesWithChord :: Chord -> [Scale]
scalesWithChord chord =
    [ scale |
      n <- [minBound..],
      t <- [minBound..],
      let scale = Scale n t,
      inScale scale chord]

chordsWithRoot :: Note -> [Chord]
chordsWithRoot n = map (Chord n) allChordTypes

chordsWithNote :: Note -> [Chord]
chordsWithNote note =
    [ chord |
      n <- [minBound..],
      t <- allChordTypes,
      let chord = Chord n t,
      inChord chord note]

inScale :: Scale -> Chord -> Bool
inScale scale chord = all (flip elem (notes scale)) (notes chord)
borrowed = (not.) . inScale

inChord :: Chord -> Note -> Bool
inChord chord note = elem note (notes chord)

scaleSharedChords :: Scale -> Scale -> [Chord]
scaleSharedChords = intersect `on` chordsInScale

noteAtScaleDegree :: Scale -> ScaleDegree -> Note
noteAtScaleDegree scale degree = (notes scale)!!(fromEnum degree)

chordsAtScaleDegrees :: Scale -> [ScaleDegree] ->  [[Chord]]
chordsAtScaleDegrees scale degrees =
    map ((filter (inScale scale)) . chordsWithRoot . (noteAtScaleDegree scale))
        degrees

twelveBarBlues :: Scale -> [[Chord]]
twelveBarBlues scale = chordsAtScaleDegrees scale [I,I,I,I,IV,IV,I,I,V,V,I,I]

resolvesChord :: Scale -> Chord -> [Chord]
resolvesChord scale (Chord note (SeventhChord triad quality)) =
    let seventh = interval 7 quality
        d7 = add note (diminish seventh)
        dd7 = add note (doublyDiminish seventh)
    in [chord |
        n <- [minBound..],
        triad <- [major, minor],
        let chord = Chord n triad,
        let ns = notes chord,
        inScale scale chord,
        elem d7 ns || elem dd7 ns]
resolvesChord _ _ = []

scalesWithProgression :: ScaleType -> [ScaleDegree] -> [ChordType] -> [Scale]
scalesWithProgression stype degrees cTypes = filter hasProgression scalesOfType
    where scalesOfType = map (\n->Scale n stype) [minBound..]
          hasProgression scale =
              all (inScale scale)
                  (zipWith (chordOfTypeAtDegree scale) degrees cTypes)
          chordOfTypeAtDegree scale degree chordType =
              Chord (noteAtScaleDegree scale degree) chordType

-- guitar
standardGuitarTuning = [E, B, G, D, A, E]

frettingChord :: [Note] -> [Int] -> Maybe Chord
frettingChord tuning notes = notesToChord $ frettingNotes tuning notes

notesToChord :: [Note] -> Maybe Chord
notesToChord notes =
    find ((all (elemOf notes)) . cNotes) $ chordsWithRoot (last notes)
    where elemOf = flip elem

frettingNotes :: [Note] -> [Int] -> [Note]
frettingNotes tuning notes = zipWith add tuning notes

-- Notes to self
tetris =
       [E, B, C, D, C, B, A, A, C, E]
    ++ [D, C, B, B, C, D, E, C, A, A]
    ++ [F, G, A, G, F, E, C, E, D, C, B, E, C, A, A]

-- Read/Show
noteNames = ["C", "C#", "D", "D#", "E", "F", "F#", "G", "G#", "A", "A#", "B"]

chordTypeNames =
    [(major,""),
     (minor,"m"),
     (augmented,"aug"),
     (diminished,"dim"),
     (diminished7th,"dim7"),
     (halfDiminished7th,"-7"),
     (minor7th,"m7"),
     (minorMajor7th,"m(M7)"),
     (dominant7th,"dom7"),
     (major7th,"M7"),
     (augmented7th,"aug7"),
     (augmentedMajor7th,"+(M7)")
     ]

instance Show Note where
    show n = noteNames!!(fromEnum n)

instance Show ChordType where
    show (SuspendedChord factor chord) = show chord ++ "sus" ++ show factor
    show ct = findName chordTypeNames
        where findName [] = error "Invalid chord type in show"
              findName ((t,n):r)
                  | t == ct = n
                  | otherwise = findName r

instance Show Chord where
    show (Chord note chordType) = show note ++ show chordType

instance Read Chord where
    readsPrec d s =
        [(Chord n t,x) |
         (n, u) <- readsPrec d s,
         (t, x) <- readsPrec d u]

instance Read Note where
    readsPrec d str = map applyFlats (readEnum noteNames str)
        where applyFlats (n,('b':rest)) = applyFlats (add n (-1), rest)
              applyFlats p = p

instance Read ChordType where
    readsPrec d str = [(findChord chordTypeNames,"")]
        where findChord [] = error "Invalid chord type in read"
              findChord ((t,n):r)
                  | n == str = t
                  | otherwise = findChord r

readEnum :: Enum a => [String] -> String -> [(a, String)]
readEnum candidates str = case longestMatch candidates str of
    Just match -> [(toEnum $ fromJust $ elemIndex match candidates,
                    fromJust $ stripPrefix match str)]
    Nothing -> []

longestMatch :: [String] -> String -> Maybe String
longestMatch candidates str =
    find (`isPrefixOf` str) (sortBy (flip (comparing length)) candidates)

